home *** CD-ROM | disk | FTP | other *** search
- /* xlobj - xlisp object functions */
-
- #ifdef CI_86
- #include "a:stdio.h"
- #include "xlisp.h"
- #endif
-
-
- #ifdef AZTEC
- #include "a:stdio.h"
- #include "xlisp.h"
- #endif
-
-
- #ifdef unix
- #include <stdio.h>
- #include <xlisp.h>
- #endif
-
-
- /* global variables */
-
- struct node *self;
-
-
- /* external variables */
-
- extern struct node *xlstack;
- extern struct node *xlenv;
-
-
- /* local variables */
-
- static struct node *class;
- static struct node *object;
- static struct node *new;
- static struct node *isnew;
- static struct node *msgcls;
- static struct node *msgclass;
- static int varcnt;
-
-
- /* instance variable numbers for the class 'Class' */
-
- #define MESSAGES 0 /* list of messages */
- #define IVARS 1 /* list of instance variable names */
- #define CVARS 2 /* list of class variable names */
- #define CVALS 3 /* list of class variable values */
- #define SUPERCLASS 4 /* pointer to the superclass */
- #define IVARCNT 5 /* number of class instance variables */
- #define IVARTOTAL 6 /* total number of instance variables */
-
-
- /* number of instance variables for the class 'Class' */
-
- #define CLASSSIZE 7
-
-
-
- /* forward declarations (the extern hack is because of decusc) */
-
- extern struct node *findmsg();
- extern struct node *findvar();
- extern struct node *defvars();
- extern struct node *makelist();
-
-
- /*****************************
- * xlclass - define a class *
- *****************************/
-
- struct node *xlclass(name,vcnt)
- char *name; int vcnt;
- {
- struct node *sym,*cls;
-
- sym = xlenter(name); /* Create the class */
- cls = sym->n_symvalue = newnode(OBJ);
- cls->n_obclass = class;
- cls->n_obdata = makelist(CLASSSIZE);
-
- if (vcnt > 0) /* Set instance var count */
- {
- (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
- (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
- }
-
- xlivar(cls,SUPERCLASS)->n_listvalue = object; /* superclass = object */
-
- return (cls);
- }
-
-
- /******************************************************************
- * xlmfind - find the message binding for a message to an object *
- ******************************************************************/
-
- struct node *xlmfind(obj,msym)
- struct node *obj,*msym;
- {
- return (findmsg(obj->n_obclass,msym));
- }
-
-
- /******************************************
- * xlxsend - send a message to an object *
- ******************************************/
-
- struct node *xlxsend(obj,msg,args)
- struct node *obj,*msg,*args;
- {
- struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv;
-
- oldenv = xlenv; /* Save old environment */
- oldstk = xlsave(&method,&cptr,&val,NULL);
-
- method.n_ptr = msg->n_msgcode; /* Get method for this msg */
- if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST)
- xlfail("bad method");
-
- xlbind(self,obj); /* Bind 'self' and 'msgclass' */
- xlbind(msgclass,msgcls);
-
- if (method.n_ptr->n_type == SUBR) /* Evaluate function */
- {
- xlfixbindings(oldenv);
- val.n_ptr = (*method.n_ptr->n_subr)(args);
- }
- else
- { /* Bind formal arguments */
- xlabind(method.n_ptr->n_listvalue,args);
- xlfixbindings(oldenv);
-
- cptr.n_ptr = method.n_ptr->n_listnext;
- while (cptr.n_ptr != NULL)
- val.n_ptr = xlevarg(&cptr.n_ptr);
- }
-
- xlunbind(oldenv); /* Restore environment */
-
- /* after creating an object, send it the "isnew" message */
- if (msg->n_msg == new && val.n_ptr != NULL)
- {
- if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
- xlfail("no method for the isnew message");
- val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
- }
-
- xlstack = oldstk; /* Restore old stack frame */
- return (val.n_ptr);
- }
-
-
- /***************************************************************
- * xlsend - send a message to an object (message in arg list) *
- ***************************************************************/
-
- struct node *xlsend(obj,args)
- struct node *obj,*args;
- {
- struct node *msg;
-
- if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
- xlfail("no method for this message");
-
- return (xlxsend(obj,msg,args));
- }
-
-
- /***********************************************************************
- * xlobsym - find a class or instance variable for the current object *
- ***********************************************************************/
-
- struct node *xlobsym(sym)
- struct node *sym;
- {
- struct node *obj;
-
- if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
- return (findvar(obj,sym));
- else
- return (NULL);
- }
-
-
- /****************************************
- * mnew - create a new object instance *
- ****************************************/
-
- static struct node *mnew()
- {
- struct node *oldstk,obj,*cls;
-
- oldstk = xlsave(&obj,NULL); /* New stack frame */
-
- cls = self->n_symvalue; /* Get class name */
-
- obj.n_ptr = newnode(OBJ); /* Generate new object */
- obj.n_ptr->n_obclass = cls;
- obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
-
- xlstack = oldstk; /* Restore old stack frame */
- return (obj.n_ptr);
- }
-
-
- /************************************
- * misnew - initialize a new class *
- ************************************/
-
- static struct node *misnew(args)
- struct node *args;
- {
- struct node *oldstk,super,*obj;
-
- oldstk = xlsave(&super,NULL); /* Create new stack frame */
-
- if (args != NULL) /* Get superclass is present */
- super.n_ptr = xlevmatch(OBJ,&args);
- else
- super.n_ptr = object;
-
- xllastarg(args); /* Check no more args */
-
- obj = self->n_symvalue; /* Get the object */
- xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
- (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
- getivcnt(super.n_ptr,IVARTOTAL);
-
- xlstack = oldstk; /* Restore stack frame */
- return (obj);
- }
-
-
- /*******************************************
- * xladdivar - enter an instance variable *
- *******************************************/
-
- xladdivar(cls,var)
- struct node *cls; char *var;
- {
- struct node *ivar,*lptr;
-
- ivar = xlivar(cls,IVARS); /* Find 'ivars' instance var */
-
- lptr = newnode(LIST); /* add instance var */
- lptr->n_listnext = ivar->n_listvalue;
- ivar->n_listvalue = lptr;
- lptr->n_listvalue = xlenter(var);
- }
-
-
- /****************************************
- * entermsg - add a message to a class *
- ****************************************/
-
- static struct node *entermsg(cls,msg)
- struct node *cls,*msg;
- {
- struct node *ivar,*lptr,*mptr;
-
- ivar = xlivar(cls,MESSAGES); /* Find 'messages' iv */
-
- for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
- if ((mptr = lptr->n_listvalue)->n_msg == msg)
- return (mptr);
-
- /* allocate a new message entry if one wasn't found */
- lptr = newnode(LIST);
- lptr->n_listnext = ivar->n_listvalue;
- ivar->n_listvalue = lptr;
- lptr->n_listvalue = mptr = newnode(LIST);
- mptr->n_msg = msg;
-
- return (mptr); /* Return the symbol node */
- }
-
-
- /*****************************************************
- * answer - define a method for answering a message *
- *****************************************************/
-
- static struct node *answer(args)
- struct node *args;
- {
- struct node *oldstk,arg,msg,fargs,code;
- struct node *obj,*mptr,*fptr;
-
- oldstk = xlsave(&arg,&msg,&fargs,&code,NULL); /* New stack frame */
- arg.n_ptr = args;
-
- msg.n_ptr = xlevmatch(SYM,&arg.n_ptr); /* Message symbol */
-
- fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* Formal arg list */
- code.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* the code */
- xllastarg(arg.n_ptr); /* End of args */
-
- obj = self->n_symvalue; /* Object node */
- mptr = entermsg(obj,msg.n_ptr); /* New message list entry */
-
- mptr->n_msgcode = fptr = newnode(LIST); /* Set up message node */
- fptr->n_listvalue = fargs.n_ptr;
- fptr->n_listnext = code.n_ptr;
-
- xlstack = oldstk; /* Restore old stack frame */
- return (obj);
- }
-
-
- /***************************************************
- * mivars - define the list of instance variables *
- ***************************************************/
-
- static struct node *mivars(args)
- struct node *args;
- {
- struct node *cls,*super;
- int scnt;
-
- cls = defvars(args,IVARS); /* Define list of ivs */
-
- if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
- scnt = getivcnt(super,IVARTOTAL);
- else
- scnt = 0;
-
- (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
- (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;
-
- return (cls);
- }
-
-
-
- /****************************************************************
- * getivcnt - get the number of instance variables for a class *
- ****************************************************************/
-
- static int getivcnt(cls,ivar)
- struct node *cls; int ivar;
- {
- struct node *cnt;
-
- if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
- if (cnt->n_type == INT)
- return (cnt->n_int);
- else
- xlfail("bad value for instance variable count");
- else
- return (0);
- }
-
-
-
- /************************************************
- * mcvars - define the list of class variables *
- ************************************************/
-
- static struct node *mcvars(args)
- struct node *args;
- {
- struct node *cls;
-
- cls = defvars(args,CVARS); /* define list of class vars */
- xlivar(cls,CVALS)->n_listvalue = makelist(varcnt); /* make new list */
-
- return (cls);
- }
-
-
-
- /*******************************************************
- * defvars - define a class or instance variable list *
- *******************************************************/
-
- static struct node *defvars(args,varnum)
- struct node *args; int varnum;
- {
- struct node *oldstk,vars,*vptr,*cls,*sym;
-
- oldstk = xlsave(&vars,NULL); /* Create new stack frame */
- vars.n_ptr = xlevmatch(LIST,&args); /* Get ivar list */
- xllastarg(args); /* Last argument ! */
-
- cls = self->n_symvalue; /* Class node */
-
- varcnt = 0; /* Check each var in list */
- for (vptr = vars.n_ptr;
- vptr != NULL && vptr->n_type == LIST;
- vptr = vptr->n_listnext)
- {
- /* make sure this is a valid symbol in the list */
- if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
- xlfail("bad variable list");
-
- if (checkvar(cls,sym)) /* Check not already defined */
- xlfail("multiply defined variable");
- varcnt++; /* Count the variable */
- }
-
- if (vptr != NULL) /* Check for correct end */
- xlfail("bad variable list");
-
- xlivar(cls,varnum)->n_listvalue = vars.n_ptr; /* Define new list */
-
- xlstack = oldstk; /* Restore old stack frame */
- return (cls);
- }
-
-
-
- /****************************************
- * xladdmsg - add a message to a class *
- ****************************************/
-
- xladdmsg(cls,msg,code)
- struct node *cls; char *msg; struct node *(*code)();
- {
- struct node *mptr;
-
- mptr = entermsg(cls,xlenter(msg)); /* enter message selector */
- mptr->n_msgcode = newnode(SUBR); /* Store the method */.
- mptr->n_msgcode->n_subr = code;
- }
-
-
-
- /******************************************
- * getclass - get the class of an object *
- ******************************************/
-
- static struct node *getclass(args)
- struct node *args;
- {
- xllastarg(args); /* Check no arguments */
- return (self->n_symvalue->n_obclass);
- }
-
-
-
- /******************************
- * obprint - print an object *
- ******************************/
-
- static struct node *obprint(args)
- struct node *args;
- {
- xllastarg(args); /* Check no arguments */
-
- printf("<Object: #%o>",self->n_symvalue);
- return (self->n_symvalue);
- }
-
-
-
- /******************************************************
- * obshow - show the instance variables of an object *
- ******************************************************/
-
- static struct node *obshow(args)
- struct node *args;
- {
- xllastarg(args); /* Check no arguments */
-
- xlprint(self->n_symvalue->n_obdata,TRUE);
- return (self->n_symvalue);
- }
-
-
-
- /**************************************
- * defisnew - default 'isnew' method *
- **************************************/
-
- static struct node *defisnew(args)
- struct node *args;
- {
- xllastarg(args); /* Check for null arg list */
- return (self->n_symvalue);
- }
-
-
-
- /*********************************************************
- * sendsuper - send a message to an object's superclass *
- *********************************************************/
-
- static struct node *sendsuper(args)
- struct node *args;
- {
- struct node *obj,*super,*msg;
-
- obj = self->n_symvalue; /* Get the object and its super class */
- super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;
-
- /* Find message binding */
- if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL)
- xlfail("no method for this message");
-
- return (xlxsend(obj,msg,args)); /* and send it */
- }
-
-
- /*******************************************************************
- * findmsg - find the message binding given an object and a class *
- *******************************************************************/
-
- static struct node *findmsg(cls,sym)
- struct node *cls,*sym;
- {
- struct node *lptr,*msg;
-
- msgcls = cls; /* Start at specified class */
- while (msgcls != NULL) /* Look for the message */
- {
- for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
- lptr != NULL;
- lptr = lptr->n_listnext)
- if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
- return (msg);
-
- msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
- }
-
- return (NULL); /* Message not found */
- }
-
-
- /************************************************
- * findvar - find a class or instance variable *
- ************************************************/
-
- static struct node *findvar(obj,sym)
- struct node *obj,*sym;
- {
- struct node *cls,*lptr;
- int base,varnum;
- int found;
-
- cls = obj->n_obclass; /* Get class of object */
- base = getivcnt(cls,IVARTOTAL); /* Get number of ivs */
-
- found = FALSE; /* Find the var */
- for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
- {
- if ((base -= getivcnt(cls,IVARCNT)) < 0)
- xlfail("error finding instance variable");
-
- if (!found && cls == msgclass->n_symvalue)
- found = TRUE;
-
- varnum = 0; /* Lookup the iv */
- for (lptr = xlivar(cls,IVARS)->n_listvalue;
- lptr != NULL;
- lptr = lptr->n_listnext)
- if (found && lptr->n_listvalue == sym)
- return (xlivar(obj,base + varnum));
- else
- varnum++;
-
- if (!found) /* Skip class vars if found */
- continue;
-
- varnum = 0; /* Lookup class vars */
- for (lptr = xlivar(cls,CVARS)->n_listvalue;
- lptr != NULL;
- lptr = lptr->n_listnext)
- if (lptr->n_listvalue == sym)
- return (xlcvar(cls,varnum));
- else
- varnum++;
- }
-
- return (NULL); /* Var not found */
- }
-
-
- /****************************************************************
- * checkvar - check for an existing class or instance variable *
- ****************************************************************/
-
- static int checkvar(cls,sym)
- struct node *cls,*sym;
- {
- struct node *lptr;
-
- for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
- {
- for (lptr = xlivar(cls,IVARS)->n_listvalue; /* Lookup instance var */
- lptr != NULL;
- lptr = lptr->n_listnext)
- if (lptr->n_listvalue == sym)
- return (TRUE);
-
- for (lptr = xlivar(cls,CVARS)->n_listvalue; /* Lookup class var */
- lptr != NULL;
- lptr = lptr->n_listnext)
- if (lptr->n_listvalue == sym)
- return (TRUE);
- }
-
- return (FALSE); /* Var not found */
- }
-
-
- /**************************************
- * xlivar - get an instance variable *
- **************************************/
-
- struct node *xlivar(obj,num)
- struct node *obj; int num;
- {
- struct node *ivar;
-
- for (ivar = obj->n_obdata; num > 0; num--) /* Get instance var */
- if (ivar != NULL)
- ivar = ivar->n_listnext;
- else
- xlfail("bad instance variable list");
-
- return (ivar);
- }
-
-
- /**********************************
- * xlcvar - get a class variable *
- **********************************/
-
- struct node *xlcvar(cls,num)
- struct node *cls; int num;
- {
- struct node *cvar;
-
- for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
- if (cvar != NULL)
- cvar = cvar->n_listnext;
- else
- xlfail("bad class variable list");
-
- return (cvar);
- }
-
-
-
- /************************************
- * makelist - make a list of nodes *
- ************************************/
-
- static struct node *makelist(cnt)
- int cnt;
- {
- struct node *oldstk,list,*lnew;
-
- oldstk = xlsave(&list,NULL); /* Create a new stack frame */
-
- for (; cnt > 0; cnt--) /* Make the list */
- {
- lnew = newnode(LIST);
- lnew->n_listnext = list.n_ptr;
- list.n_ptr = lnew;
- }
-
- xlstack = oldstk; /* Restore the old stack frame */
- return (list.n_ptr);
- }
-
-
- /*****************************************************
- * xloinit - object function initialization routine *
- *****************************************************/
-
- xloinit()
- {
- class = NULL; /* Dont confuse gc */
- object = NULL;
-
- new = xlenter("new"); /* Enter object realtaed symbols */
- isnew = xlenter("isnew");
- self = xlenter("self");
- msgclass = xlenter("msgclass");
-
- class = xlclass("Class",CLASSSIZE); /* Create 'Class' object */
- class->n_obclass = class;
-
- object = xlclass("Object",0); /* Create 'Object class */
-
- xlivar(class,SUPERCLASS)->n_listvalue = object;
- xladdivar(class,"ivartotal"); /* ivar number 6 */
- xladdivar(class,"ivarcnt"); /* ivar number 5 */
- xladdivar(class,"superclass"); /* ivar number 4 */
- xladdivar(class,"cvals"); /* ivar number 3 */
- xladdivar(class,"cvars"); /* ivar number 2 */
- xladdivar(class,"ivars"); /* ivar number 1 */
- xladdivar(class,"messages"); /* ivar number 0 */
- xladdmsg(class,"new",mnew);
- xladdmsg(class,"answer",answer);
- xladdmsg(class,"ivars",mivars);
- xladdmsg(class,"cvars",mcvars);
- xladdmsg(class,"isnew",misnew);
-
- xladdmsg(object,"class",getclass);
- xladdmsg(object,"print",obprint);
- xladdmsg(object,"show",obshow);
- xladdmsg(object,"isnew",defisnew);
- xladdmsg(object,"sendsuper",sendsuper);
- }